home *** CD-ROM | disk | FTP | other *** search
/ TOS Silver 2000 / TOS Silver 2000.iso / Tools / TWILIGHT / TL_SOURC.E / PASCAL / VERSUCH.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1993-07-13  |  4.1 KB  |  205 lines
  1. unit tlm_mod;
  2. interface
  3. uses tl_inter;
  4.  
  5. type
  6. ParBlk=Record                    (* der Parameterblock TYPE für's VDI *)
  7.     p_cntrl:^integer;
  8.     p_intin:^integer;
  9.     p_ptsin:^integer;
  10.     p_intout:^integer;
  11.     p_ptsout:^integer;
  12. end;
  13.  
  14. var                    (* die arrays fürs vdi und das handle *)
  15.     contrl:array [0.. 11] of integer;
  16.     intin :array [0..127] of integer;
  17.     intout:array [0..127] of integer;
  18.     ptsin :array [0..127] of integer;
  19.     ptsout:array [0..127] of integer;
  20.     vdi_hnd:integer;
  21.  
  22. (* der Parameterblock HIMSELF für's VDI *)
  23.  
  24. const VdiParBlk:ParBlk
  25. =
  26. (   p_cntrl:@contrl;
  27.     p_intin:@intin;
  28.     p_ptsin:@ptsin;
  29.     p_intout:@intout;
  30.     p_ptsout:@ptsout;
  31. );
  32.  
  33. procedure TLM_START(tl_info:INFO_PTR);
  34.  
  35. implementation
  36.  
  37. {$S-}
  38. {$L-}
  39. {$V-}
  40. {$D-}
  41. {$I-}
  42.  
  43. type
  44.  
  45. GRECT=                (* typ eines GRECT's *)
  46. record
  47.    x,y,w,h:integer;
  48. end;
  49.  
  50. GRECT_PTR=^GRECT;    (* ein pointer darauf *)
  51.  
  52.  
  53. (* ein paar VDI funktionen *)
  54.  
  55. procedure rect(x1,y1,x2,y2:integer);
  56. begin
  57.     ptsin[0]:=x1;
  58.     ptsin[1]:=y1;
  59.     ptsin[2]:=x2;
  60.     ptsin[3]:=y2;
  61.     contrl[0]:=11;    (* GDP         *)
  62.     contrl[1]:=2;    (* 2 punkte     *)
  63.     contrl[2]:=0;    (* 0 ptsout        *)
  64.     contrl[3]:=0;    (* no intin's    *)
  65.     contrl[4]:=0;    (*                *)
  66.     contrl[5]:=1;    (* v_bar        *)
  67.     contrl[6]:=vdi_hnd;
  68.     VDI();
  69. end;
  70.  
  71. procedure line(x1,y1,x2,y2:integer);
  72. begin
  73.     ptsin[0]:=x1;
  74.     ptsin[1]:=y1;
  75.     ptsin[2]:=x2;
  76.     ptsin[3]:=y2;
  77.     contrl[0]:=6;    (* v_pline         *)
  78.     contrl[1]:=2;    (* 2 punkte     *)
  79.     contrl[2]:=0;    (* 0 ptsout        *)
  80.     contrl[3]:=0;    (* no intin's    *)
  81.     contrl[4]:=0;    (*                *)
  82.     contrl[6]:=vdi_hnd;
  83.     VDI();
  84. end;
  85.  
  86. procedure set_para(para,vdi_func:integer);
  87. begin
  88.     intin[0]:=para;
  89.     contrl[0]:=vdi_func;    (* vsl_color         *)
  90.     contrl[1]:=0;        (* 0 punkte     *)
  91.     contrl[2]:=0;        (* 0 punkte     *)
  92.     contrl[3]:=1;        (* 1 intin's    *)
  93.     if vdi_func=17 then
  94.         contrl[4]:=1    (* color 1 zurück *)
  95.     else
  96.         contrl[4]:=0;    (* sonst keinen *)
  97.     contrl[6]:=vdi_hnd;
  98.     VDI();
  99. end;
  100.  
  101. procedure wrmode(m:integer); begin set_para(m,32); end;
  102. procedure ltype( l:integer); begin set_para(l,15); end;
  103. procedure lcolor(c:integer); begin set_para(c,17); end;
  104. procedure finter(c:integer); begin set_para(c,23); end;
  105. procedure fstyle(c:integer); begin set_para(c,24); end;
  106. procedure fcolor(c:integer); begin set_para(c,25); end;
  107.  
  108. procedure lwidth(    l:integer);     
  109. begin
  110.     ptsin[0]:=l;
  111.     ptsin[1]:=0;
  112.     contrl[0]:=16;    (* vsl_color         *)
  113.     contrl[1]:=1;    (* 1 punkte     *)
  114.     contrl[2]:=1;
  115.     contrl[3]:=0;    (* 1 intin's    *)
  116.     contrl[4]:=0;    (* 1 intin's    *)
  117.     contrl[6]:=vdi_hnd;
  118.     VDI();
  119. end;
  120.  
  121. procedure lends(    beg,    ende:integer);
  122. begin
  123.     intin[0]:=beg;
  124.     intin[1]:=ende;
  125.     contrl[0]:=108;    (* vsl_color         *)
  126.     contrl[1]:=0;    (* 1 punkte     *)
  127.     contrl[2]:=0;
  128.     contrl[3]:=2;    (* 1 intin's    *)
  129.     contrl[4]:=0;    (* 1 intin's    *)
  130.     contrl[6]:=vdi_hnd;
  131.     VDI();
  132. end;
  133.  
  134. (* bei Übergabe von NIL clipping AUS, sonst auf das Rechteck, auf das der pointer zeigt AN *)
  135.  
  136. procedure set_clip(rect: GRECT_PTR);
  137. begin
  138.     if(rect<>NIL) then
  139.     with rect^ do
  140.     begin
  141.         ptsin[0]:=x;
  142.         ptsin[1]:=y;
  143.         ptsin[2]:=x+w-1;
  144.         ptsin[3]:=y+h-1;
  145.         intin[0]:=1;
  146.     end
  147.     else
  148.         intin[0]:=0;
  149.     contrl[0]:=129;    (* vs_clip         *)
  150.     contrl[1]:=2;    (* 0 punkte     *)
  151.     contrl[2]:=0;    (* 0 punkte zurück     *)
  152.     contrl[3]:=1;    (* 1 intin's    *)
  153.     contrl[4]:=0;    (* 0 ints zurück     *)
  154.     contrl[6]:=vdi_hnd;
  155.     VDI();
  156. end;
  157.  
  158. (* dummy random function *)
  159.  
  160. var sseeeedd:longint;
  161.  
  162. function random(range:integer):integer;
  163. begin
  164.     sseeeedd:=sseeeedd*1145314615+12345;
  165.     random:=integer( (longint(range)*sseeeedd)shr 16);
  166. end;
  167.  
  168. procedure TLM_START(tl_info:INFO_PTR);
  169. var clip:GRECT;
  170.     c,x,dir:integer;
  171. begin
  172.     sseeeedd:=ms200;
  173.     c:=1;
  174.     vdi_hnd:=tl_info^.tl_handle;
  175.     clip.x:=0;
  176.     clip.y:=0;
  177.     clip.w:=tl_info^.max_x+1;
  178.     clip.h:=tl_info^.max_y+1;
  179.     wrmode(1);
  180.     ltype(1);
  181.     lwidth(3);
  182.     lends(1,1); 
  183.  
  184. (*    finter(1);
  185.     fstyle(4);
  186. *)
  187.     x:=0;
  188.     dir:=10;
  189.     set_clip(@clip);
  190.     repeat
  191.         
  192.         lcolor(c);
  193.         if (c>=tl_info^.max_colors) then
  194.             c:=0
  195.         else
  196.             c:=c+1;
  197.         if(dir>0)and(x+dir>tl_info^.max_x) then dir:= -dir;
  198.         if(dir<0)and(x+dir<0)              then begin dir:= -dir; x:=x+3; end;
  199.         x:=x+dir;
  200.         line(x,0,x,tl_info^.max_y);
  201.  
  202.     until (tl_info^.tl_check()<>0);
  203. end;
  204.  
  205. end.